perm filename PCROSS.OLD[PAS,SYS]2 blob
sn#470635 filedate 1979-08-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*THINGS YET TO DO:
C00006 00003 (*DESCRIPTION AND HISTORY*)
C00010 00004 (*VALID SWITCHES*)
C00018 00005 (*GLOBAL DECLARATIONS*)
C00021 00006 TYPE
C00043 00007 (*INITPROCEDURES*) (*REINITIALIZE*) (*GETCOUNTS*) (*INITIALIZE*)
C00057 00008 (*GETDIRECTIVES[*) (*SETSWITCH*) (*]*)
C00066 00009 (*PAGE CONTROL:*) (*HEADER*) (*NEWPAGE*)
C00070 00010 (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
C00085 00011 (*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*READLINE]*) (*RESWORD*) (*FINDNAME*) (*INSERTCALL*)
C00100 00012 (*PARENTHESE*) (*DOCOMMENT[*) (*OPTIONS]*) (*SKIP_E_DIRECTORY*)
C00104 00013 (*] INSYMBOL*)
C00111 00014 (*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
C00118 00015 (*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat*)
C00135 00016 (*]BLOCK*)
C00145 00017 (*PRINT_XREF_LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
C00158 00018 (*MAIN PROGRAM*)
C00161 ENDMK
C⊗;
(*THINGS YET TO DO:
COMMENTS ON THE LEFT SIDE.
VERSION (% - \): out!
*)
(*$T-,R64,D- *) (*TITLE PAGE*)
(*%SETt PCREF *)
(*%SETT SAIL *)
(********************************************************************************
*
* P C R O S S
* ***********
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1976,
* H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
*
*
* PCROSS IS A ONE-SOURCE, TWO OBJECTS PROGRAM THAT CONTAINS A
* PRETTYPRINTER (PFORM) AND A CROSS-REFERENCER (PCREF) OF PASCAL
* SOURCE PROGRAMS. IT DERIVES FROM CROSS, WHICH COMES WITH THE
* HAMBURG COMPILER FOR DECSYSTEM-10 AND -20.
*
* TO SWITCH IT BACK AND FORTH BETWEEN THE TWO SOURCES CONTAINED IN
* IT, IT USES THE FEATURES OF VERCH, DERIVED FROM CONDCOMP, CREATED
* BY RICHARD SITES AND IMPROVED BY PETER NYE AND ARMANDO RODRIGUEZ
* AT STANFORD ARTIFICIAL INTELLIGENCE LABORATORY, FOR THE PROJECT
* S-1.
*
*
(********************************************************************************
(*DESCRIPTION AND HISTORY*)
(**********************************************************************
*
*
* PROGRAM WHICH CREATES A CROSS REFERENCE LISTING
* AND A NEW, REFORMATTED VERSION OF A PASCAL PROGRAM.
*
* INPUT: PASCAL SOURCE FILE.
* OUTPUT: NEW REFORMATTED SOURCE FILE AND
* CROSS-REFERENCE LISTING.
*
* FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
* MANUEL MALL, UNIVERSITY OF HAMBURG. (1974)
*
* DATE UNKNOWN. LARRY PAULSON (STANFORD).
* + MAKE THE FILES OF TYPE TEXT
* + NOT AS MANY FORCED NEWLINES.
* + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
*
* MAR-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + A NEW SET OF SWITCH OPTIONS.
* + SOME NEW ERRORS ARE REPORTED.
*
* JUL-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + ACCEPT NON-STANDARD COMMENT CONVENTIONS. STANDARIZE THEM.
* + IMPROVE THE CROSS REFERENCE LISTING.
* + LISTING OF PROC-FUNC CALL NESTING.
* + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCEDURES.
*
* SEE THE PROCEDURE GETDIRECTIVES FOR THE AVAILABLE SWITCHES.
*
* DEC-78. ARMANDO R. RODRIGUEZ (STANFORD)
* + SPEED UP AND CLEANNING OF THE CODE.
* + FIX SMALL BUGS.
*
* MAR-79. ARMANDO R. RODRIGUEZ
* + IMPLEMENT STATEMENT COUNTS.
*
* JUL-79. ARMANDO R. RODRIGUEZ.
* + IMPLEMENT A WIDER /VERSION SWITCH SYSTEM
* + SEPARATE IT INTO PFORM AND PCREF
* + ADAPT IT FOR THE LINEPRINTER AT SAIL.
* + IMPROVE THE IMPLEMENTATION OF STATEMENT COUNTS.
* + FIX BUGS.
* + SEPARATE IT INTO PCREF AND PFORM.
*
* THINGS TO BE FIXED, OR DOCUMENTED:
* PCREF:
* + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
* + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
* AS A PROC FOR CALL-NESTING.
* + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
* THAT WON'T BE USED, WHEN CROSS IS NOT 15.
*
*
(**********************************************************************)
(*VALID SWITCHES*)
(*---------------------------------------------------------------------
!
! FOR PCREF,
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! (DEFAULTS IN PARENS ARE AT SAIL) <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /CROSS[:<N>] WRITTING OF THE CROSSLIST FILE. ON,15
! <N> IS THE SUM OF:
! 1 SOURCE PROGRAM LISTING
! 2 LISTING OF IDENTIFIERS
! 4 LISTING OF PROC-FUNC
! DECLARATION NESTING.
! 8 LISTING OF PROC-FUNC CALL NESTING.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /WIDTH:<N> MAXIMUM LINE LENGTH IN CROSSLIST 132 (120)
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4
! /INCREMENT:<N> LINE NUMBER INCREMENT 100
! /[NO]DOTS PUT AS A GUIDE A DOTTED LINE AT THE LEFT
! MARGIN EVERY FIFTH LINE ON
! /[NO]HEAD BREAK THE FILE IN PAGES WITH HEADERS FOR PRINT ON
! /LINES:<N> NUMBER OF LINES PER PAGE 57 (51)
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. L (U)
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
!
! /[NO]DEBUG CREATE A FILE PCREF.BUG WITH THE COUNTS THAT
! WHERE NOT INCLUDED IN THE LISTING (PROFILE) OFF
!
!--------
!
! NOTE: IF A FILE .KNT IS FOUND, THE STATEMENT COUNTS FROM
! PROFILING THE PROGRAM WILL BE INSERTED, AND THE
! DEFAULT OF THE NEXT SWITCHES WILL CHANGE:
!
! /CROSS 1
! /FORCE ON
!
+--------------------------------------------------------------------*)
(*---------------------------------------------------------------------
!
! FOR PFORM,
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! (DEFAULTS IN PARENS ARE AT SAIL) <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4,3 (LOTS,SAIL)
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. L (U)
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
+--------------------------------------------------------------------*)
(*GLOBAL DECLARATIONS*)
(*%IFT PCREF *)
%\
%PROGRAM PCREF;\
%\
(*%else pcref (IFF) *)
PROGRAM pform ;
(*%ENDC PCREF (ELSE) (IFF) *)
CONST
(*%IFT PCREF *)
(*%IFT SAIL *)
% VERSION = 'PCREF/SAIL 1.0 10-JUL-79';\
(*%ELSE SAIL (IFF) *)
% VERSION = 'PCREF/LOTS 1.0 10-JUL-79';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ELSE PCREF (IFF) *)
(*%IFT SAIL *)
version = 'PFORM/SAIL 1.0 10-JUL-79';
(*%ELSE SAIL (IFF) *)
% VERSION = 'PFORM/LOTS 1.0 10-JUL-79';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ENDC PCREF (ELSE) (IFF) *)
verlength = 10;
backslash = '\';
linsize = 600; (*maximum size of an input line*)
linsizplus2 = 602; (*linsize + 2*)
ht = 11B; (*ASCII TAB*)
blanks = ' '; (*FOR EDITING PURPOSES*)
(*%IFT SAIL *)
linnumsize = 3;
(*%ELSE SAIL (IFF) *)
% LINNUMSIZE = 5;\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%IFT PCREF *)
% COUNTERSIZE = 8; (*FIELD SIZE FOR THE STATEMENT COUNT VALUE*)\
% MAX_LINE_COUNT = 7777B; (*LIMIT OF LINES/EDIT-PAGE*)\
% MAX_PAGE_COUNT = 77B; (*LIMIT OF EDIT-PAGES*)\
% (* MAX_LINE_COUNT AND MAX_PAGE_COUNT SHOULD NOT NEED MORE THAN 18 BITS TOTAL*)\
(*%IFT SAIL *)
% STDMAXLINE = 51; \
% MAXCROSSCH = 120; \
% MARGIN = 14; \
% DOTS = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . +';\
(*%ELSE SAIL (IFF) *)
% STDMAXLINE = 57; (*MAXIMUM NUMBER OF LINES PER PAGE, IGNORING HEADER*)\
% MAXCROSSCH = 132; \
% MARGIN = 16; \
% DOTS = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . +';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ENDC PCREF *)
TYPE
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
missgrpar,missgquote,missgmain,missgpoint,linetoolong,
missgrbrack,missguntil);
symbol = (labelsy,constsy,typesy,varsy,programsy, (*DECSYM*)
functionsy,proceduresy,initprocsy, (*PROSYM*)
endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*ENDSYMBOLS*)
beginsy,casesy,loopsy,repeatsy,ifsy, (*BEGSYM*)
recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*DELIMITER*));
(*%IFT PCREF *)
% LINEPTRTY = ↑LINE;\
% LISTPTRTY = ↑LIST;\
% PROCSTRUCTY = ↑PROCSTRUC;\
% CALLEDTY = ↑CALLED;\
%\
% LINENRTY = 0..MAX_LINE_COUNT;\
% PAGENRTY = 0..MAX_PAGE_COUNT;\
%\
% LINE = PACKED RECORD\
% (*DESCRIPTION OF THE LINE NUMBER*)\
% LINENR : LINENRTY; (*LINE NUMBER*)\
% PAGENR : PAGENRTY; (*PAGE NUMBER*)\
% CONTLINK : LINEPTRTY; (*NEXT LINE NUMBER RECORD*)\
% DECLFLAG: CHAR; (*'D' IF DECLARATION, 'M' IF MULTIPLE OCCURRENCE,\
% BLANK OTHERWISE*)\
% END;\
%\
% LIST = PACKED RECORD\
% (*DESCRIPTION OF IDENTIFIERS*)\
% NAME : ALFA; (*NAME OF THE IDENTIFIER*)\
% LLINK , (*LEFT SUCCESSOR IN TREE*)\
% RLINK : LISTPTRTY; (*RIGHT SUCCESSOR IN TREE*)\
% FIRST , (*POINTER TO FIRST LINE NUMBER RECORD*)\
% LAST : LINEPTRTY; (*POINTER TO LAST LINE NUMBER RECORD*)\
% EXTERNFLAG: CHAR; (*'E' IF EXTERNAL, 'F' IF FORWARD,\
% 'D' IF TWO PROCS WITH THE SAME NAME, BLANK OTHERWISE*)\
% PROFUNFLAG : CHAR; (*'P' IF PROCEDURE NAME, 'F' IF FUNCTION, BLANK OTHERWISE*)\
% PROCDATA: PROCSTRUCTY;\
% END;\
%\
%\
% PROCSTRUC = PACKED RECORD\
% (*DESCRIPTION OF THE PROCEDURE NESTING*)\
% PROCNAME : LISTPTRTY; (*POINTER TO THE APPROPRIATE IDENTIFIER*)\
% NEXTPROC : PROCSTRUCTY; (*POINTER TO THE NEXT ELEMENT*)\
% LINENR, (*LINE NUMBER OF THE PROCEDURE DEFINITION*)\
% BEGLINE, (*LINE NUMBER OF THE BEGIN STATEMENT*)\
% ENDLINE: LINENRTY; (*LINENUMBER OF THE END STATEMENT*)\
% PAGENR , (*PAGE NUMBER OF THE PROCEDURE DEFINITION*)\
% BEGPAGE, (*PAGE NUMBER OF THE BEGIN STATEMENT*)\
% ENDPAGE, (*PAGE NUMBER OF THE END STATEMENT*)\
% PROCLEVEL: PAGENRTY; (*NESTING DEPTH OF THE PROCEDURE*)\
% FIRSTCALL: CALLEDTY; (*LIST OF PROCEDURES CALLED BY THIS ONE*)\
% PRINTED: BOOLEAN; (*TO AVOID LOOPS IN THE CALL-NEST LIST*)\
% END;\
%\
% CALLED = PACKED RECORD\
% NEXTCALL : CALLEDTY;\
% WHOM : PROCSTRUCTY;\
% END;\
(*%ELSE PCREF (IFF) *)
linenrty = 0..maxint;
pagenrty = 0..maxint;
(*%ENDC PCREF (ELSE) (IFF) *)
VAR
(* (*INPUT CONTROL*)
(* (***************)
bufflen, (*LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER*)
buffmark, (*LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER*)
bufferptr, (*POINTER TO THE NEXT CHARACTER IN THE BUFFER*)
syleng: integer; (*LENGTH OF THE LAST READ IDENTIFIER OR LABEL*)
(* (*NESTING AND MATCHING CONTROL*)
(* (******************************)
level, (*NESTING DEPTH OF THE CURRENT PROCEDURE*)
variant_level, (*NESTING DEPTH OF VARIANTS*)
errcount: integer; (*COUNTS THE ERRORS ENCOUNTERED*)
(*%IFT PCREF *)
% BMARKNR, (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.*)\
% EMARKNR, (*NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.*)\
% BLOCKNR: INTEGER; (*COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'*)\
(*%ENDC PCREF *)
(* (*FORMATTING*)
(* (************)
increment, (*LINE NUMBER INCREMENT*)
indentbegin, (*INDENTATION AFTER A BEGIN*)
begexd, (*EXDENTATION FOR BEGIN-END PAIRS*)
feed, (*INDENTATION BY PROCEDURES AND BLOCKS*)
spaces, (*INDENTATION FOR THE CURRENT LINE*)
lastspaces, (*ONE-TIME OVERRIDING VALUE FOR SPACES*)
goodversion, (*KEEPS THE VALUE OF THE VERSION OPTION*)
pagecnt, (*COUNTS THE FILE PAGES*)
maxinc, (*GREATEST ALLOWABLE LINE NUMBER*)
maxch, (*MAXIMUM LENGTH OF SOURCE LINE IN CROSSLIST*)
line500, (*TO GIVE A TTY MESSAGE EVERY 500 LINES*)
linecnt : integer; (*COUNTS THE LINES PER FILE PAGE*)
tabs: ARRAY [1:17] OF ascii; (*A STRING OF TABS FOR FORMATTING*)
lower : ARRAY [ascii] OF ascii; (*TO MAP UPPER TO LOWER CASE IF DESIRED*)
(*%IFT PCREF *)
% COUNTLINE, (*NEXT LINE FOR STATEMENT COUNTER*)\
% COUNTPAGE, (*PAGE OF NEXT LINE FOR STATEMENT COUNTER*)\
% COUNTTIMES, (*STATEMENT COUNT OF COUNTLINE/COUNTPAGE*)\
% MAXCOUNTTIMES, (*COUNT OF THE LINE WITH HIGHER COUNTTIMES*)\
% MAXCOUNTLINE, (*LINE FOR MAXCOUNTTIMES*)\
% MAXCOUNTPAGE, (*PAGE FOR MAXCOUNTTIMES*)\
% PAGECNT2, (*COUNTS THE PRINT PAGES PER FILE PAGE*)\
% MAXLINE, (*NUMBER OF LINES PER PAGE*)\
% REALLINCNT, (*COUNTS THE LINES PER PRINT PAGE*)\
% SOURCELINE, (*TO MATCH SOS LINES*)\
% SOURCEPAGE: INTEGER;\
%\
% PROCSTRUCDATA : RECORD\
% (*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)\
% EXISTS : BOOLEAN;\
% ITEM : PROCSTRUC;\
% END;\
(*%ENDC PCREF *)
(* (*SCANNING*)
(* (**********)
buffer : ARRAY [-1..linsizplus2] OF ascii; (*INPUT BUFFER*)
(* BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)
linenb : PACKED ARRAY [1..5] OF char; (*SOS-LINE NUMBER*)
prog_name: alfa; (*NAME OF CURRENT PROGRAM*)
sy : alfa; (*LAST SYMBOL READ*)
syty : symbol; (*TYPE OF THE LAST SYMBOL READ*)
(*%IFT PCREF *)
% CURPROCNAME, (*NAME OF THE CURRENT PROCEDURE/FUNCTION, FOR THE HEADER*)\
% DATE_TEXT,TIME_TEXT: ALFA; (*HEADING DATE AND TIME*)\
% MARKSYTY, (*TYPE OF THE SYMBOL BEFORE THE LAST IF*)\
% PREVSYTY: SYMBOL; (*TYPE OF THE PREVIOUS SYMBOL*)\
(*%ENDC PCREF *)
(* (*VERSION SYSTEM*)
(* (****************)
incondcomp: boolean;
(* (*SWITCHES*)
(* (**********)
elseifing, (*set if the sequence else if should stay in one line*)
debugging, (*SET IF THE UNPRINTED COUNTS ARE TO BE REPORTED*)
forcing, (*SET IF THEN, ELSE, DO, REPEAT WILL FORCE NEWLINE*)
rescase, (*SET IF RESERVED WORDS WILL UPSHIFT*)
nonrcase, (*SET IF NONRESERVED WORDS WILL UPSHIFT*)
comcase, (*SET IF COMMENTS WILL UPSHIFT*)
strcase, (*SET IF STRINGS WILL UPSHIFT*)
thendo, (*SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED*)
anyversion: boolean; (*SET IF GOODVERSION > 9*)
(*%IFT PCREF *)
% CROSSING, (*SET IF THE CROSSLIST FILE IS BEING WRITEN*)\
% REFING, (*SET IF THE REFERENCES WILL BE PRINTED*)\
% DECNESTING, (*SET IF THE PRO-FUNC DECLARATION LISTING WILL BE PRINTED*)\
% CALLNESTING, (*SET IF THE PRO-FUNC CALL NESTING WILL BE PRINTED*)\
% DOTTING, (*SET IF DOTED LINES WILL BE PRINTED AT LEFT MARGIN*)\
% COUNTING, (*SET IF A .KNT EXISTS, FOR STATEMENT COUNTS*)\
% HEADING: BOOLEAN; (*SET IF THE LISTING PAGES TAKE HEADERS*)\
(*%ENDC PCREF *)
(* (*OTHER CONTROLS*)
(* (****************)
notokenyet, (*set in each line until the first token is scanned*)
elsehere, (*set while an else token is to be printed*)
fwddecl, (*SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'*)
oldspaces, (*SET WHEN LASTSPACES SHOULD BE USED*)
eoline, (*SET AT END ON INPUT LINE*)
programpresent, (*SET AFTER PROGRAM ENCOUNTERED*)
nobody, (*SET IF NO MAIN BODY IS FOUND*)
firstpage, (*TRUE BEFORE WRITTING ANYTHING*)
eob : boolean; (*EOF-FLAG*)
errmsg : PACKED ARRAY[errkinds,1..40] OF char; (*ERROR MESSAGES*)
ch : ascii; (*LAST READ CHARACTER*)
(*%IFT SAIL *)
diring, (*set if the e-directory should be printed*)
skipping: boolean; (*SET WHILE SKIPPING THE E-DIRECTORY*)
(*%ENDC SAIL *)
(*%IFT PCREF *)
% nocountyet, (*SET WHEN COUNTING, FORCING, AND AN ELSE IS HERE*)\
% GOTOINLINE, (*SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE*)\
% DECLARING, (*SET WHILE PARSING DECLARATIONS*)\
% STMTPART: BOOLEAN; (*SET IF PROCESSING THE STATEMENT PART*)\
% BMARKTEXT, (*CHARACTER FOR MARKING OF 'BEGIN' ETC.*)\
% EMARKTEXT: CHAR; (*CHARACTER FOR MARKING OF 'END' ETC.*)\
(*%ENDC PCREF *)
(* (*SETS*)
(* (******)
delsy : ARRAY [' '..'_'] OF symbol; (*TYPE ARRAY FOR DELIMITER CHARACTERS*)
resnum: ARRAY['A'..'['] OF integer; (*INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER*)
reslist : ARRAY [1..46] OF alfa; (*LIST OF THE RESERVED WORDS*)
ressy : ARRAY [1..46] OF symbol; (*TYPE ARRAY OF THE RESERVED WORDS*)
alphanum, (*CHARACTERS FROM 0..9 AND A..Z*)
digits : SET OF char; (*CHARACTERS FROM 0..9*)
openblocksym, (*SYMBOLS AFTER WHICH A BASIC BLOCK STARTS*)
relevantsym, (*START SYMBOLS FOR STATEMENTS AND PROCEDURES*)
prosym, (*ALL SYMBOLS WHICH BEGIN A PROCEDURE*)
decsym, (*ALL SYMBOLS WHICH BEGIN DECLARATIONS*)
begsym, (*ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS*)
endsym : SET OF symbol; (*ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES*)
(* (*POINTERS AND FILES*)
(* (********************)
old_name: pack9; (*USED TO GET THE PARAMETER FILES*)
old_dev: pack6;
old_prot,old_ppn: integer;
programname,oldfileid: alfa;
oldsource: text;
(*%IFF PCREF *)
new_name: pack9;
new_dev: pack6;
new_prot,new_ppn: integer;
newfileid: alfa;
newsource: text;
(*%ENDC PCREF *)
(*%IFT PCREF *)
% LISTPTR, HEAPMARK : LISTPTRTY; (*POINTER INTO THE BINARY TREE OF THE IDENTIFIER*)\
% FIRSTNAME : ARRAY ['A'..'Z'] OF LISTPTRTY; (*POINTER TO THE ROOTS OF THE TREE*)\
% PROCSTRUCF, (*POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST*)\
% PROCSTRUCL : PROCSTRUCTY; (*POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST*)\
% WORKCALL: CALLEDTY;\
%\
% COUNTFILENAME, (*NAME OF THE STATEMENT COUNTS FILE*)\
% CROSS_NAME,LINK_NAME: PACK9;\
% LINK_DEVICE,CROSS_DEV:PACK6;\
% CROSS_PROT,CROSS_PPN: INTEGER;\
% CROSSFILEID: ALFA;\
% DEBUGFILE,\
% CROSSLIST: TEXT; (*FILES PROCESSED BY THIS PROGRAM*)\
% COUNTFILE: FILE OF INTEGER; (*FILE FOR STATEMENT COUNTS*)\
(*%ENDC PCREF *)
(*INITPROCEDURES*) (*REINITIALIZE*) (*GETCOUNTS*) (*INITIALIZE*)
INITPROCEDURE;
BEGIN (*CONSTANTS*)
diring := false;
elsehere := false;
elseifing := false;
eob := false;
indentbegin:=0;
begexd:=0;
goodversion := -1;
rescase:=true;
nonrcase:=false;
strcase:=true;
nobody := false;
anyversion := false;
oldfileid:='OLDSOURCE ';
(*%IFT SAIL *)
feed := 3;
comcase := true;
(*%ELSE SAIL (IFF) *)
% FEED:=4; \
% COMCASE:=FALSE; \
(*%ENDC SAIL (ELSE) (IFF) *)
(*%IFT PCREF *)
% DEBUGGING := FALSE;\
% HEADING := TRUE;\
% CROSSING:=TRUE;\
% REFING:=FALSE;\
% DECNESTING:=FALSE;\
% CALLNESTING:=FALSE;\
% DOTTING:=TRUE;\
% CROSS_NAME:=' ';\
% PROGRAMNAME := 'PCREF '; \
% CROSSFILEID:='CROSSLIST ';\
(*%IFT SAIL *)
% INCREMENT := 1; \
(*%ELSE SAIL (IFF) *)
% INCREMENT:=100; \
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ELSE PCREF (IFF) *)
new_name:=' ';
programname:='PFORM ';
newfileid:='NEWSOURCE ';
(*%ENDC PCREF (ELSE) (IFF) *)
END (*CONSTANTS*);
INITPROCEDURE;
BEGIN (*RESERVED WORDS*)
resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4;
resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13;
resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19;
resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22;
resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27;
resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33;
resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39;
resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43;
resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43;
reslist[ 1] :='AND '; ressy [ 1] := othersy;
reslist[ 2] :='ARRAY '; ressy [ 2] := othersy;
reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy;
reslist[ 4] :='CASE '; ressy [ 4] := casesy;
reslist[ 5] :='CONST '; ressy [ 5] := constsy;
reslist[ 6] :='DO '; ressy [ 6] := dosy;
reslist[ 7] :='DIV '; ressy [ 7] := othersy;
reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy;
reslist[ 9] :='END '; ressy [ 9] := endsy;
reslist[10] :='ELSE '; ressy [10] := elsesy;
reslist[11] :='EXIT '; ressy [11] := exitsy;
reslist[12] :='EXTERN '; ressy [12] := externsy;
reslist[13] :='FOR '; ressy [13] := forsy;
reslist[14] :='FILE '; ressy [14] := othersy;
reslist[15] :='FORWARD '; ressy [15] := forwardsy;
reslist[16] :='FUNCTION '; ressy [16] := functionsy;
reslist[17] :='FORTRAN '; ressy [17] := externsy;
reslist[18] :='GOTO '; ressy [18] := gotosy;
reslist[19] :='IF '; ressy [19] := ifsy;
reslist[20] :='IN '; ressy [20] := othersy;
reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
reslist[22] :='LOOP '; ressy [22] := loopsy;
reslist[23] :='LABEL '; ressy [23] := labelsy;
reslist[24] :='MOD '; ressy [24] := othersy;
reslist[25] :='NOT '; ressy [25] := othersy;
reslist[26] :='NIL '; ressy [26] := othersy;
reslist[27] :='OR '; ressy [27] := othersy;
reslist[28] :='OF '; ressy [28] := ofsy;
reslist[29] :='OTHERS '; ressy [29] := otherssy;
reslist[30] :='PACKED '; ressy [30] := othersy;
reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
reslist[32] :='PROGRAM '; ressy [32] := programsy;
reslist[33] :='RECORD '; ressy [33] := recordsy;
reslist[34] :='REPEAT '; ressy [34] := repeatsy;
reslist[35] :='SET '; ressy [35] := othersy;
reslist[36] :='THEN '; ressy [36] := thensy;
reslist[37] :='TO '; ressy [37] := othersy;
reslist[38] :='TYPE '; ressy [38] := typesy;
reslist[39] :='UNTIL '; ressy [39] := untilsy;
reslist[40] :='VAR '; ressy [40] := varsy;
reslist[41] :='WHILE '; ressy [41] := whilesy;
reslist[42] :='WITH '; ressy [42] := othersy;
END (*RESERVED WORDS*);
INITPROCEDURE;
BEGIN (*SETS*)
digits := ['0'..'9'];
alphanum := ['0'..'9','A'..'Z'] (*LETTERS OR DIGITS*);
decsym := [labelsy,constsy,typesy,varsy,programsy];
prosym := [functionsy..initprocsy];
endsym := [functionsy..eobsy]; (*PROSYM OR ENDSYMBOLS*)
begsym := [beginsy..ifsy];
relevantsym := [labelsy..initprocsy (*DECSYM OR PROSYM*),beginsy,forwardsy,externsy,eobsy];
openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
END (*SETS*);
INITPROCEDURE;
BEGIN (*ERROR MESSAGES*)
errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
errmsg[missgend ] := 'MISSING ''END'' STATEMENT NUMBER ';
errmsg[missgthen ] := 'MISSING ''THEN'' FOR ''IF'' NUMBER ';
errmsg[missgof ] := 'MISSING ''OF'' IN ''CASE'' NUMBER ';
errmsg[missgexit ] := 'MISSING ''EXIT'' IN ''LOOP'' NUMBER ';
errmsg[missgrpar ] := 'MISSING RIGHT PARENTHESIS ';
errmsg[missgquote ] := 'MISSING CLOSING QUOTE ON THIS LINE ';
errmsg[missgmain ] := 'WARNING: THIS FILE HAS NO MAIN BODY ';
errmsg[missgpoint ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
errmsg[linetoolong ] := 'LINE TOO LONG. I''M GONNA GET CONFUSED. ';
errmsg[missguntil ] := 'MISSING ''UNTIL'' FOR ''REPEAT'' NUMBER ';
errmsg[missgrbrack ] := 'MISSING RIGHT BRACKET ';
END (*ERROR MESSAGES*);
PROCEDURE reinitialize;
VAR
lch: char;
BEGIN (*REINITIALIZE*)
bufflen := 0; buffmark := 0; errcount := 0;
bufferptr := 2; variant_level := 0; level := 0;
line500 := 0; linecnt :=0; pagecnt := 1;
eoline := true; firstpage := true; notokenyet := true;
programpresent := false; oldspaces := false; incondcomp := false;
sy := blanks; prog_name := blanks;
(*%IFT SAIL *)
skipping := false;
(*%ENDC SAIL *)
(*%IFT PCREF *)
% NEW(HEAPMARK); (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)\
% WORKCALL := NIL;\
%\
% PAGECNT2 := 0; SOURCEPAGE := 1; SOURCELINE := 0;\
% MAXCOUNTPAGE := 0; MAXCOUNTLINE := 0; MAXCOUNTTIMES := 0;\
% BLOCKNR := 0; REALLINCNT:= MAXLINE;\
%\
% DECLARING := TRUE; GOTOINLINE := FALSE; nocountyet := FALSE;\
% PROCSTRUCDATA.EXISTS := FALSE;\
%\
% BMARKTEXT := ' '; EMARKTEXT := ' '; CH := ' ';\
%\
% DATE(DATE_TEXT); TIME(TIME_TEXT);\
%\
% FOR LCH := 'A' TO 'Z' DO\
% FIRSTNAME [LCH] := NIL;\
% NEW (FIRSTNAME['M']);\
% LISTPTR := FIRSTNAME ['M'];\
% WITH FIRSTNAME ['M']↑ DO\
% BEGIN\
% NAME := 'MAIN PROGM';\
% LLINK := NIL;\
% RLINK := NIL;\
% PROFUNFLAG := 'M';\
% NEW (FIRST);\
% LAST := FIRST;\
% WITH LAST↑ DO\
% BEGIN\
% LINENR := 1;\
% PAGENR:=1;\
% CONTLINK := NIL;\
% END;\
% END;\
%\
% NEW (PROCSTRUCF);\
% WITH PROCSTRUCF↑ DO\
% BEGIN\
% PROCNAME := FIRSTNAME ['M'];\
% NEXTPROC := NIL;\
% LINENR := 1;\
% PAGENR:=1;\
% PROCLEVEL:= 0;\
% FIRSTCALL := NIL;\
% END;\
% PROCSTRUCL := PROCSTRUCF;\
% CURPROCNAME := 'MAIN PROGM';\
(*%ENDC PCREF *)
END (*REINITIALIZE*);
(*%IFT PCREF *)
%PROCEDURE GETCOUNTS;\
% BEGIN\
% IF EOF(COUNTFILE) THEN\
% BEGIN\
% COUNTLINE := 99999;\
% COUNTPAGE := 99999;\
% END\
% ELSE\
% BEGIN\
% COUNTPAGE := COUNTFILE↑;\
% GET(COUNTFILE);\
% COUNTLINE := COUNTFILE↑;\
% GET(COUNTFILE);\
% COUNTTIMES := COUNTFILE↑;\
% GET(COUNTFILE);\
% END;\
% END (*GETCOUNTS*);\
(*%ENDC PCREF *)
PROCEDURE initialize;
VAR
i: integer;
BEGIN (*INITIALIZE*)
FOR ch := ' ' TO '_' DO
delsy [ch] := othersy;
delsy ['('] := lparent;
delsy [')'] := rparent;
delsy ['['] := lbracket;
delsy [']'] := rbracket;
delsy [';'] := semicolon;
delsy ['.'] := point;
delsy [':'] := colon;
delsy ['='] := eqlsy;
FOR i := -1 TO 201 DO
buffer [i] := ' ';
FOR i := 1 TO 17 DO
tabs [i] := chr (ht);
FOR ch := nul TO '@' DO
lower[ch] := ch;
FOR ch := 'A' TO 'Z' DO
lower[ch] := chr (ord(ch) + 40B);
FOR ch := '[' TO del DO
lower[ch] := ch;
reinitialize;
END (*INITIALIZE*);
(*GETDIRECTIVES[*) (*SETSWITCH*) (*]*)
PROCEDURE getdirectives;
(* CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES. *)
VAR
brkchar: char;
try: integer;
fromtmp: boolean;
PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
VAR
i: integer;
BEGIN (*SETSWITCH*)
getoption(opt,i);
IF i=ord('L') THEN
switch:=false
ELSE
IF i=ord('U') THEN
switch:=true;
END (*SETSWITCH*);
BEGIN (*GETDIRECTIVES*)
(*%IFT SAIL *) (*OPEN OLDSOURCE*)
askfilename(old_name,old_prot,old_ppn,old_dev,oldfileid,programname,false,fromtmp,brkchar);
startfile(oldsource,old_name,old_prot,old_ppn,old_dev,true,oldfileid,'PAS');
(*%ELSE SAIL (IFF) *)
% GETPARAMETER(OLDSOURCE,OLDFILEID,PROGRAMNAME,TRUE);\
(*%ENDC SAIL (ELSE) (IFF) *)
getstatus(oldsource,old_name,old_prot,old_ppn,old_dev);
(*%IFT PCREF *) (*OPEN CROSSLIST AND COUNTFILE*)
% ASKFILENAME(CROSS_NAME,CROSS_PROT,CROSS_PPN,CROSS_DEV,CROSSFILEID,PROGRAMNAME,FALSE,FROMTMP,BRKCHAR);\
% IF (CROSS_NAME = ' ') AND (CROSS_DEV = 'DSK ') THEN\
% BEGIN\
% CROSS_NAME := OLD_NAME;\
% CROSS_NAME[7]:='L';\
% CROSS_NAME[8]:='S';\
% CROSS_NAME[9]:='T';\
% END;\
% STARTFILE(CROSSLIST,CROSS_NAME,CROSS_PROT,CROSS_PPN,CROSS_DEV,FALSE,CROSSFILEID,' ');\
%\
% COUNTFILENAME := OLD_NAME;\
% COUNTFILENAME[7] := 'K';\
% COUNTFILENAME[8] := 'N';\
% COUNTFILENAME[9] := 'T';\
% RESET(COUNTFILE,COUNTFILENAME);\
% IF EOF(COUNTFILE) THEN\
% RESET (COUNTFILE,COUNTFILENAME,OLD_PROT,OLD_PPN,OLD_DEV);\
% COUNTING := NOT EOF(COUNTFILE);\
% IF COUNTING THEN\
% BEGIN\
% FORCING := TRUE;\
(*%IFT SAIL *)
% CALLNESTING := FALSE;\
% DECNESTING := FALSE;\
% REFING := FALSE;\
(*%ENDC SAIL *)
% GETCOUNTS;\
% END;\
%\
% IF COUNTING THEN\
% BEGIN\
% WRITELN(TTY);\
% WRITELN(TTY,'I FOUND ',COUNTFILENAME:6,'.KNT: WILL DO STATEMENT COUNTS');\
% END;\
% BREAK(TTY);\
%\
(*%IFT SAIL *)
% BEGIN\
(*%ENDC SAIL *)
if (not option('cross ')) and counting then
try := 1
else
begin
% GETOPTION('CROSS ',TRY);\
% IF TRY = 0 THEN\
% TRY:=15;\
end;
% CALLNESTING:=TRY > 7;\
% DECNESTING:=(TRY MOD 8) > 3;\
% REFING:= (TRY MOD 4) > 1;\
% CROSSING:=(TRY MOD 2) = 1;\
(*%IFT SAIL *)
% END;\
(*%ENDC SAIL *)
%\
(*%ELSE PCREF (IFF) *) (*OPEN NEWSOURCE*)
askfilename(new_name,new_prot,new_ppn,new_dev,newfileid,programname,false,fromtmp,brkchar);
IF (new_name = ' ') AND (new_dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, new_name,old_prot,old_ppn,old_dev);
new_name[7]:='N';
new_name[8]:='E';
new_name[9]:='W';
END;
startfile(newsource,new_name,new_prot,new_ppn,new_dev,false,newfileid,' ');
(*%ENDC PCREF (ELSE) (IFF) *)
IF option ('VERSION ') THEN
BEGIN
getoption ('VERSION ',goodversion);
IF goodversion > 9 THEN
BEGIN
goodversion := -1;
anyversion := true;
END;
END;
IF option('INDENT ') THEN
BEGIN
getoption('INDENT ',feed);
IF feed < 0 THEN
feed:=4;
END;
IF option('BEGIN ') THEN
BEGIN
getoption('BEGIN ',indentbegin);
IF indentbegin < 0 THEN
BEGIN
begexd:=-indentbegin;
indentbegin:=0;
END;
END;
forcing:=forcing OR option('FORCE ');
elseifing := option ('elseif ');
IF option('CASE ') THEN
BEGIN
setswitch('CASE ',rescase);
nonrcase:=rescase;
comcase:=rescase;
strcase:=rescase;
END;
setswitch('RES ',rescase);
setswitch('NONRES ',nonrcase);
setswitch('COMM ',comcase);
setswitch('STR ',strcase);
(*%IFT sail *)
diring := option ('dir ');
(*%endc sail *)
(*%IFT PCREF *)
% IF option('INCREMENT ') THEN\
% BEGIN\
% getoption('INCREMENT ',increment);\
% IF increment < 0 THEN\
% increment:= 100;\
% END;\
%\
% DEBUGGING := OPTION ('DEBUG ');\
% IF DEBUGGING THEN\
% REWRITE(DEBUGFILE,'PCREF.BUG');\
%\
% HEADING := NOT OPTION('NOHEAD ');\
%\
% IF OPTION('LINES ') AND HEADING THEN\
% BEGIN\
% GETOPTION('LINES ',MAXLINE);\
% IF MAXLINE <= 0 THEN\
% MAXLINE := MAXINT;\
% END\
% ELSE\
% MAXLINE := STDMAXLINE;\
%\
% IF OPTION('WIDTH ') THEN\
% GETOPTION('WIDTH ',MAXCH)\
% ELSE\
% MAXCH := MAXCROSSCH;\
% MAXCH := MAXCH - MARGIN;\
%\
% DOTTING:=NOT OPTION('NODOTS ');\
%\
(*%ENDC PCREF *)
END (*GETDIRECTIVES*);
(*PAGE CONTROL:*) (*HEADER*) (*NEWPAGE*)
(*%IFT PCREF *)
%PROCEDURE HEADER (NAME: ALFA);\
% (*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)\
% BEGIN (*HEADER*)\
% if crossing then\
% begin\
% PAGECNT2 := PAGECNT2 + 1;\
% REALLINCNT := 0;\
% IF HEADING THEN\
% BEGIN\
(*%IFT SAIL *)
% IF NOT (FIRSTPAGE OR SKIPPING) THEN\
% PAGE(CROSSLIST);\
% WRITE(CROSSLIST,VERSION:26,' ':7,OLD_NAME:6,'.',OLD_NAME[7],OLD_NAME[8],OLD_NAME[9],\
% ' [ ',PROG_NAME,' ] ', DATE_TEXT, ' ', TIME_TEXT);\
% WRITELN (CROSSLIST, 'PAGE ':13, PAGECNT:3, '-', PAGECNT2:2, NAME:15);\
% WRITELN(CROSSLIST); \
% END (*IF HEADING*)\
% else\
% if pagecnt2 = 1 then\
% IF NOT (FIRSTPAGE OR SKIPPING) THEN\
% PAGE(CROSSLIST);\
% FIRSTPAGE := FALSE;\
(*%ELSE SAIL (IFF) *)
% IF FIRSTPAGE THEN\
% FIRSTPAGE := FALSE\
% ELSE\
% PAGE(CROSSLIST);\
% IF HEADING THEN\
% BEGIN\
% WRITE(CROSSLIST,VERSION:28,' ':10,OLD_NAME:6,'.',OLD_NAME[7],OLD_NAME[8],OLD_NAME[9],\
% ' [ ',PROG_NAME,' ]',' ':9, DATE_TEXT, ' ', TIME_TEXT);\
% WRITELN (CROSSLIST, 'PAGE ':15, PAGECNT:3, '-', PAGECNT2:2, NAME:15);\
% WRITELN(CROSSLIST);\
% END (*IF HEADING*);\
(*%ENDC SAIL (ELSE) (IFF) *)
% end (*if crossing*);\
% END (*HEADER*);\
(*%ENDC PCREF *)
PROCEDURE newpage;
BEGIN (*NEWPAGE*)
pagecnt := pagecnt + 1;
IF eoln (oldsource) THEN
readln(oldsource);
linecnt := 0;
line500 := 0;
IF prog_name <> blanks THEN
write(tty,pagecnt:3,'..');
break(tty);
(*%IFT PCREF *)
% PAGECNT2 := 0;\
% HEADER (CURPROCNAME);\
(*%ELSE PCREF (IFF) *)
(*%IFT SAIL *)
IF NOT skipping THEN
(*%ENDC SAIL *)
IF firstpage THEN
firstpage := false
ELSE
page(newsource);
(*%ENDC PCREF (ELSE) (IFF) *)
END (*NEWPAGE*);
(*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
PROCEDURE block;
VAR
i: integer;
itisaproc : boolean; (*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
lastprocname: alfa; (*IMPLICIT STACK OF PROCEDURE NAMES FOR THE HEADER*)
(*%IFT PCREF *)
% CURPROC : LISTPTRTY; (*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)\
% LOCPROCSTL: PROCSTRUCTY;\
(*%ENDC PCREF *)
PROCEDURE error (errnr : errkinds);
BEGIN (*ERROR*)
errcount := errcount+1;
(*%IFT PCREF *)
% REALLINCNT := REALLINCNT + 1; (*COUNT THE LINE FOR THE ERROR MESSAGE ON CROSSLIST*)\
% WRITE (CROSSLIST, ' ':17,' *??* ');\
% CASE ERRNR OF\
% BEGERRINBLKSTR: WRITE(CROSSLIST, SY, ERRMSG[BEGERRINBLKSTR]);\
% MISSGEND, MISSGTHEN, MISSGUNTIL,\
% MISSGEXIT : WRITE(CROSSLIST, ERRMSG[ERRNR],EMARKNR : 4);\
% OTHERS : WRITE(CROSSLIST, ERRMSG[ERRNR]);\
% END;\
% WRITELN(CROSSLIST,' *??*');\
(*%ELSE PCREF (iff) *)
write (newsource, '(*??* ');
CASE errnr OF
begerrinblkstr: write(newsource, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit : write(newsource, errmsg[errnr]);
OTHERS : write(newsource, errmsg[errnr]);
END;
writeln(newsource,' *??*)');
(*%ENDC PCREF (ELSE) (IFF) *)
writeln(tty);
write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
CASE errnr OF
begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit :
(*%IFT PCREF *)
% WRITE(TTY, ERRMSG[ERRNR],EMARKNR : 4);\
(*%ELSE PCREF (IFF) *)
write(tty, errmsg[errnr]);
(*%ENDC PCREF (ELSE) (IFF) *)
OTHERS : write(tty, errmsg[errnr]);
END;
writeln(tty);
break (tty);
END (*ERROR*) ;
PROCEDURE writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*): integer);
VAR
ladjust,
i, j, maxchar: integer; (*MARKIERT ERSTES ZU DRUCKENDES ZEICHEN*)
(*%IFT PCREF *)
% PROCEDURE USEDOTS(LASTSPACES: INTEGER);\
%\
% BEGIN (*USEDOTS*)\
% (*USE EITHER DOTS OR SPACES TO MAKE INDENTATION*)\
% IF LASTSPACES >= 0 THEN\
% IF DOTTING AND ((REALLINCNT MOD 5) = 0) THEN\
% WRITE(CROSSLIST,DOTS: LASTSPACES)\
% ELSE (*NO DOTS IN THIS LINE*)\
% BEGIN\
% LASTSPACES := LASTSPACES;\
% IF LASTSPACES > 7 THEN\
% LASTSPACES := LASTSPACES + 2 + LINNUMSIZE;\
% WRITE(CROSSLIST, TABS: LASTSPACES DIV 8, ' ': LASTSPACES MOD 8);\
% END;\
% IF COUNTING THEN (*IF MAKING STATEMENT COUNTS, PRINT THE COUNT*)\
% BEGIN\
% WHILE (SOURCEPAGE > COUNTPAGE) DO (*FIND THE COUNT FOR THIS LINE*)\
% BEGIN\
% IF DEBUGGING THEN\
% WRITELN(DEBUGFILE,COUNTLINE,COUNTPAGE,COUNTTIMES);\
% GETCOUNTS;\
% END;\
% IF SOURCEPAGE = COUNTPAGE THEN\
% WHILE SOURCELINE > COUNTLINE DO\
% BEGIN\
% IF DEBUGGING THEN\
% WRITELN(DEBUGFILE,COUNTLINE,COUNTPAGE,COUNTTIMES);\
% GETCOUNTS;\
% END;\
% IF (COUNTLINE = SOURCELINE) AND (COUNTPAGE = SOURCEPAGE) AND\
% NOT nocountyet THEN\
% BEGIN (*IF IT EXISTS, PRINT IT*)\
% WRITE(CROSSLIST,COUNTTIMES:COUNTERSIZE,'-+ ');\
% IF COUNTTIMES >= MAXCOUNTTIMES THEN\
% BEGIN\
% MAXCOUNTTIMES := COUNTTIMES;\
% MAXCOUNTLINE := SOURCELINE;\
% MAXCOUNTPAGE := SOURCEPAGE;\
% END;\
% GETCOUNTS;\
% END\
% ELSE (*NO COUNT HERE*) (*OTHERWISE, FILL THE SPACE*)\
% IF DOTTING AND ((REALLINCNT MOD 5) = 0) THEN\
% IF STMTPART THEN\
% WRITE(CROSSLIST,DOTS:COUNTERSIZE+1,'! ')\
% ELSE\
% WRITE(CROSSLIST,DOTS:COUNTERSIZE+7,' ')\
% ELSE\
% IF STMTPART THEN\
% WRITE(CROSSLIST,'!':COUNTERSIZE+2,' ':6)\
% ELSE\
% WRITE(CROSSLIST,' ':COUNTERSIZE+8);\
% END (*COUNTING*)\
% ELSE (*NOT COUNTING*)\
% WRITE(CROSSLIST,' ');\
% END (*USEDOTS*);\
(*%ENDC PCREF *)
BEGIN (*WRITELINE*)
position := position - 2;
IF position > 0 THEN
BEGIN
i := buffmark + 1; (* 1. DISCARD BLANKS AT BOTH ENDS *)
WHILE (buffer [i] = ' ') AND (i <= position) DO
i := i + 1;
buffmark := position;
WHILE (buffer [position] = ' ') AND (i < position) DO
position := position - 1;
IF i <= position THEN (* 2. IF ANYTHING LEFT, WRITE IT. *)
BEGIN
IF NOT oldspaces THEN
lastspaces := spaces;
(*%IFT PCREF *)
% if crossing then\
% begin\
% IF REALLINCNT >= MAXLINE THEN\
% HEADER (CURPROCNAME);\
% REALLINCNT := REALLINCNT + 1;\
%\
% IF GOTOINLINE THEN (* 2.1.1. LEFT MARGIN *)\
% BEGIN\
% WRITE(CROSSLIST, '***GOTO***');\
% GOTOINLINE := FALSE;\
% BMARKTEXT:=' ';\
% EMARKTEXT:=' ';\
% END\
% ELSE\
% BEGIN\
% IF BMARKTEXT <> ' ' THEN\
% BEGIN\
% WRITE (CROSSLIST, BMARKTEXT, BMARKNR : 3, ' ');\
% BMARKTEXT := ' ';\
% END\
% ELSE\
% WRITE(CROSSLIST,' ');\
% IF EMARKTEXT <> ' ' THEN\
% BEGIN\
% WRITE (CROSSLIST,EMARKTEXT,EMARKNR : 3,' ');\
% EMARKTEXT := ' ';\
% END\
% ELSE\
% WRITE (CROSSLIST,' ');\
% END;\
%\
% WRITE (CROSSLIST, LINECNT * INCREMENT : LINNUMSIZE); (* 2.1.2. LINENUMBER AND INDENTATION *)\
% USEDOTS(LASTSPACES);\
% MAXCHAR:=MAXCH+I-LASTSPACES-1;\
% IF COUNTING THEN\
% MAXCHAR := MAXCHAR - COUNTERSIZE+7;\
%\
% FOR J := I TO POSITION DO (* 2.1.3. CONTENTS OF THE LINE *)\
% BEGIN\
% IF J > MAXCHAR THEN\
% BEGIN\
% WRITELN(CROSSLIST);\
% IF REALLINCNT = MAXLINE THEN\
% HEADER (BLANKS);\
% REALLINCNT:=REALLINCNT+1;\
% WRITE(CROSSLIST,' ':MARGIN);\
% LADJUST := MIN(20,POSITION-J+1);\
% IF MAXCH - LASTSPACES - FEED > LADJUST THEN\
% BEGIN\
% USEDOTS(LASTSPACES+FEED-1);\
% MAXCHAR:=MAXCH+J-LASTSPACES-1;\
% END\
% ELSE\
% BEGIN\
% USEDOTS(MAXCH - LADJUST);\
% MAXCHAR := LADJUST;\
% END;\
% END;\
% CROSSLIST↑ := BUFFER[J];\
% PUT(CROSSLIST);\
% END;\
% WRITELN(CROSSLIST);\
% end;\
%\
(*%ELSE PCREF (IFF) *)
write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
FOR j := i TO position DO
BEGIN
newsource↑ := buffer[j];
put(newsource);
END;
writeln(newsource);
(*%ENDC PCREF (ELSE) (IFF) *)
WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO (* 3. RESET POINTERS AND FLAGS *)
buffmark := buffmark + 1;
IF buffmark < bufflen THEN
IF buffer[buffmark - 1] = ' ' THEN
buffmark := buffmark - 1
ELSE
ELSE
IF (linenb = ' ') THEN
BEGIN
newpage;
(*%IFT PCREF *)
% SOURCEPAGE := SOURCEPAGE + 1;\
% SOURCELINE := 0;\
(*%ENDC PCREF *)
END
ELSE
IF (linecnt >= maxinc) THEN
newpage;
END (* IF I <= POSITION *);
END (* IF POSITION > 0 *);
lastspaces := spaces;
oldspaces := false;
thendo := false;
elsehere := false;
(*%IFT PCREF *)
% nocountyet := FALSE;\
(*%ENDC PCREF *)
END (*WRITELINE*) ;
(*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*READLINE]*) (*RESWORD*) (*FINDNAME*) (*INSERTCALL*)
PROCEDURE insymbol ;
LABEL
1,111;
VAR
i: integer;
incondcomp: boolean;
PROCEDURE readbuffer;
(*READS A CHARACTER FROM THE INPUT BUFFER*)
PROCEDURE readline;
(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
(WITHOUT LEADING BLANKS) INTO BUFFER*)
VAR
ch : char;
i: integer;
BEGIN (*READLINE*)
(*ENTERED AT THE BEGINNING OF A LINE*)
LOOP
WHILE eoln (oldsource) AND NOT eof (oldsource) DO
BEGIN
(*IS THIS A PAGE MARK?*)
getlinenr (oldsource,linenb);
readln(oldsource);
IF linenb = ' ' THEN
BEGIN
newpage;
(*%IFT PCREF *)
% SOURCEPAGE := SOURCEPAGE + 1;\
% SOURCELINE := 0;\
(*%ENDC PCREF *)
END
ELSE (*HANDLE BLANK LINE*)
BEGIN
line500 := line500 + 1;
linecnt := linecnt + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
(*%IFT PCREF *)
% IF (LINENB = '-----') AND COUNTING THEN\
% SOURCELINE := SOURCELINE + 1;\
% IF REALLINCNT = MAXLINE THEN\
% HEADER (CURPROCNAME);\
% REALLINCNT := REALLINCNT + 1;\
% if crossing then\
% WRITELN (CROSSLIST, CHR(HT),' ',LINECNT * INCREMENT : LINNUMSIZE);\
(*%ELSE PCREF (IFF) *)
writeln(newsource);
(*%ENDC PCREF (ELSE) (IFF) *)
IF linecnt >= maxinc THEN
newpage;
END (*HANDLE BLANK LINE*);
END (*WHILE EOLN(OLDSOURCE)...*);
EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
get(oldsource);
END (*LOOP*);
bufflen := 0;
(*READ IN THE LINE*)
WHILE NOT eoln (oldsource) DO
BEGIN
bufflen := bufflen + 1;
buffer [bufflen] := oldsource↑;
get(oldsource);
END;
IF bufflen > linsize THEN
BEGIN
error(linetoolong);
bufflen := linsize;
END
ELSE
BEGIN
buffer[bufflen+1] := ' '; (*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
buffer[bufflen+2] := ' ';
END;
IF NOT eof (oldsource) THEN
BEGIN
getlinenr (oldsource,linenb);
(*%IFT PCREF *)
% IF COUNTING THEN\
% IF LINENB = '-----' THEN\
% SOURCELINE := SOURCELINE + 1\
% ELSE\
% BEGIN\
% SOURCELINE := 0;\
% FOR I := 1 TO 5 DO\
% SOURCELINE := SOURCELINE * 10 + ORD(LINENB[I]) - ORD('0');\
% END;\
(*%ENDC PCREF *)
linecnt := linecnt + 1;
line500 := line500 + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
readln(oldsource);
END;
bufferptr := 1;
buffmark := 0;
notokenyet := true;
END (*READLINE*) ;
BEGIN (*READBUFFER*)
(*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
IF eoline THEN
BEGIN
(*%IFT SAIL *)
IF skipping THEN
firstpage := false
ELSE
(*%ENDC SAIL *)
writeline (bufferptr);
ch := ' ';
IF eof (oldsource) THEN
eob := true
ELSE
readline;
END
ELSE
BEGIN
ch := buffer [bufferptr];
bufferptr := bufferptr + 1;
END;
eoline := bufferptr >= bufflen + 2;
END (*READBUFFER*) ;
FUNCTION resword: boolean ;
(*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
VAR
i,j: integer;
local: boolean;
BEGIN (*RESWORD*)
local:= false;
i := resnum[sy[1]];
WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
IF reslist[ i ] = sy THEN
BEGIN
local := true;
syty := ressy [i];
IF NOT rescase THEN
FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[j] := lower[buffer[j]];
END
ELSE
i := i + 1;
resword := local;
END (*RESWORD*) ;
(*%IFT PCREF *)
% PROCEDURE FINDNAME(CURPROC: LISTPTRTY);\
% VAR\
% LPTR: LISTPTRTY; (*ZEIGER AUF DEN VORGAENGER IM BAUM*)\
% ZPTR : LINEPTRTY; (*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE*)\
% FOUND, (*SET AFTER IDENTIFIER IS FOUND*)\
% RIGHT: BOOLEAN; (*MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM*)\
% INDEXCH : CHAR; (*INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)*)\
%\
% BEGIN (*FINDNAME*)\
% INDEXCH := SY [1];\
% LISTPTR := FIRSTNAME [INDEXCH];\
% (*SEARCH IN THE TREE FOR THE IDENTIFIER*)\
% FOUND := FALSE;\
% WHILE NOT FOUND AND (LISTPTR <> NIL) DO\
% BEGIN\
% LPTR:= LISTPTR;\
% IF SY = LISTPTR↑.NAME THEN\
% BEGIN\
% FOUND := TRUE;\
% IF (LISTPTR↑.PROFUNFLAG IN ['P', 'F']) AND (NOT DECLARING) THEN\
% IF LOCPROCSTL↑.PROCLEVEL + 1 >= LISTPTR↑.PROCDATA↑.PROCLEVEL THEN\
% BEGIN\
% NEW (WORKCALL);\
% WORKCALL↑.WHOM := LISTPTR↑.PROCDATA;\
% WORKCALL↑.NEXTCALL := NIL;\
% END;\
% ZPTR := LISTPTR↑.LAST;\
% IF (ZPTR↑.LINENR <> LINECNT) OR (ZPTR↑.PAGENR <> PAGECNT) THEN\
% BEGIN\
% NEW (LISTPTR↑.LAST);\
% WITH LISTPTR↑.LAST↑ DO\
% BEGIN\
% LINENR := LINECNT;\
% PAGENR := PAGECNT;\
% CONTLINK := NIL;\
% IF DECLARING THEN\
% DECLFLAG := 'D'\
% ELSE\
% DECLFLAG := ' ';\
% END;\
% ZPTR↑.CONTLINK := LISTPTR↑.LAST;\
% END\
% ELSE\
% ZPTR↑.DECLFLAG := 'M';\
% END\
% ELSE\
% IF SY > LISTPTR↑.NAME THEN\
% BEGIN\
% LISTPTR:= LISTPTR↑.RLINK;\
% RIGHT:= TRUE;\
% END\
% ELSE\
% BEGIN\
% LISTPTR:= LISTPTR↑.LLINK;\
% RIGHT:= FALSE;\
% END;\
% END;\
% IF NOT FOUND THEN\
% BEGIN (*UNKNOWN IDENTIFIER*)\
% NEW (LISTPTR);\
% WITH LISTPTR↑ DO\
% BEGIN\
% NAME := SY;\
% LLINK := NIL;\
% RLINK := NIL;\
% PROFUNFLAG := ' ';\
% EXTERNFLAG := ' ';\
% PROCDATA := NIL;\
% END;\
% IF FIRSTNAME [INDEXCH] = NIL THEN\
% FIRSTNAME [INDEXCH] := LISTPTR\
% ELSE\
% IF RIGHT THEN\
% LPTR↑.RLINK := LISTPTR\
% ELSE\
% LPTR↑.LLINK := LISTPTR;\
% WITH LISTPTR↑ DO\
% BEGIN\
% NEW (FIRST);\
% WITH FIRST↑ DO\
% BEGIN\
% LINENR := LINECNT;\
% PAGENR := PAGECNT;\
% CONTLINK := NIL;\
% IF DECLARING THEN\
% DECLFLAG := 'D'\
% ELSE\
% DECLFLAG := ' ';\
% END;\
% LAST := FIRST ;\
% END;\
% END;\
% END (*FINDNAME*) ;\
(*%ENDC PCREF *)
(*%IFT PCREF *)
% PROCEDURE INSERTCALL;\
% VAR\
% LASTCALL,\
% THISCALL: CALLEDTY;\
% REPEATED : BOOLEAN; (*SET IF SY IS A PROC-NAME AND IS ALREADY IN THE CALL SEQUENCE*)\
%\
% BEGIN (*INSERTCALL*)\
% IF LOCPROCSTL↑.FIRSTCALL = NIL THEN\
% LOCPROCSTL↑.FIRSTCALL := WORKCALL\
% ELSE\
% BEGIN\
% THISCALL := LOCPROCSTL↑.FIRSTCALL;\
% REPEATED := FALSE;\
% WHILE (THISCALL <> NIL) AND NOT REPEATED DO\
% IF THISCALL↑.WHOM↑.PROCNAME↑.NAME = WORKCALL↑.WHOM↑.PROCNAME↑.NAME THEN\
% REPEATED := TRUE\
% ELSE\
% BEGIN\
% LASTCALL := THISCALL;\
% THISCALL := THISCALL↑.NEXTCALL;\
% END;\
% IF NOT REPEATED THEN\
% LASTCALL↑.NEXTCALL := WORKCALL;\
% END;\
% WORKCALL := NIL;\
% END (*INSERTCALL*);\
(*%ENDC PCREF *)
(*PARENTHESE*) (*DOCOMMENT[*) (*OPTIONS]*) (*SKIP_E_DIRECTORY*)
PROCEDURE parenthese (which: symbol);
(*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PARTS OF RECORDS*)
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN*)
BEGIN (*PARENTHESE*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := lastspaces + bufferptr - buffmark - 2;
(*%IFT PCREF *)
% (*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)\
% IF DECLARING THEN\
% REPEAT\
% INSYMBOL;\
% CASE SYTY OF\
% COLON: DECLARING := FALSE;\
% SEMICOLON: DECLARING := TRUE;\
% END;\
% UNTIL SYTY IN [WHICH,EXTERNSY..WHILESY,LABELSY..TYPESY,INITPROCSY..EXITSY,DOSY..FORWARDSY]\
% ELSE\
(*%ENDC PCREF *)
REPEAT
insymbol;
UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = which THEN
insymbol
ELSE
IF which = rparent THEN
error(missgrpar)
ELSE
error(missgrbrack);
END (*PARENTHESE*) ;
PROCEDURE docomment (dellength: integer; firstch: char);
VAR
oldspacesmark: integer;
BEGIN (* DOCOMMENT *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
lastspaces := spaces;
oldspaces := true;
END;
spaces := spaces + bufferptr - 2;
IF dellength = 2 THEN
WHILE NOT ((ch = ')') AND (buffer[bufferptr-2] = '*')) DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END
ELSE
WHILE ch <> firstch DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END;
repeat
readbuffer;
until (ch <> ' ') or eoline;
if eoline and notokenyet then
readbuffer;
spaces := oldspacesmark;
END (*DOCOMMENT*);
(*%IFT SAIL *)
PROCEDURE skip_e_directory;
BEGIN (*SKIP_E_DIRECTORY*)
if not diring then
skipping := true;
WHILE pagecnt = 1 DO
readbuffer;
skipping := false;
END (*SKIP_E_DIRECTORY*);
(*%ENDC SAIL *)
(*] INSYMBOL*)
BEGIN (*INSYMBOL*)
(*%IFT PCREF *)
% PREVSYTY := SYTY;\
(*%ENDC PCREF *)
111:
syleng := 0;
(*%IFT SAIL *)
WHILE (ch IN ['_','(',' ','$','?','@','%',backslash,'"','#']) AND NOT eob DO
(*%ELSE SAIL (IFF) *)
% WHILE (CH IN ['_','(',' ','$','?','@','%',BACKSLASH,'!']) AND NOT EOB DO\
(*%ENDC SAIL (ELSE) (IFF) *)
CASE ch OF
'(':
BEGIN
readbuffer;
IF (ch = '*') THEN
docomment (2,'*')
ELSE
BEGIN
syty := lparent;
IF variant_level = 0 THEN
parenthese(rparent);
GOTO 1;
END;
END;
'%':
BEGIN
incondcomp := false;
readbuffer;
IF NOT anyversion THEN
WHILE ch IN digits DO
BEGIN
IF ord(ch) - ord('0') = goodversion THEN
incondcomp := true;
readbuffer;
END;
IF NOT (incondcomp OR anyversion) THEN
docomment (1,'\');
END;
(*%IFT SAIL *)
'"':
BEGIN
readbuffer;
docomment(1,'"');
END;
(*%ENDC SAIL *)
OTHERS:
readbuffer;
END;
CASE ch OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
syleng := 0;
sy := ' ';
REPEAT
syleng := syleng + 1;
IF syleng <= 10 THEN
sy [syleng] := ch;
readbuffer;
UNTIL NOT (ch IN (alphanum + ['_']));
(*%IFT SAIL *)
IF firstpage AND (sy = 'COMMENT ') THEN
BEGIN
skip_e_directory;
GOTO 111;
END
ELSE
(*%ENDC SAIL *)
IF NOT resword THEN
BEGIN
syty := ident ;
(*%IFT PCREF *)
% FINDNAME(CURPROC);\
(*%ENDC PCREF *)
IF NOT nonrcase THEN
FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[i] := lower[buffer[i]];
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
syleng := syleng + 1;
readbuffer;
UNTIL NOT (ch IN digits);
syty := intconst;
IF ch = 'B' THEN
readbuffer
ELSE
BEGIN
IF ch = '.' THEN
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN digits);
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
IF ch = 'E' THEN
BEGIN
readbuffer;
IF ch IN ['+','-'] THEN
readbuffer;
WHILE ch IN digits DO
readbuffer;
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
END;
END;
'''':
BEGIN
syty := strgconst;
repeat
REPEAT
IF NOT strcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
UNTIL (ch = '''') OR eob OR eoline;
IF ch <> '''' THEN
error(missgquote);
readbuffer;
until ch <> '''';
END;
(*%IFT SAIL *)
'!':
(*%ELSE SAIL (IFF) *)
% '"': \
(*%ENDC SAIL (ELSE) (IFF) *)
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN (digits + ['A'..'F']));
syty := intconst;
END;
' ': syty := eobsy; (*END OF FILE*)
':': BEGIN
readbuffer;
IF ch = '=' THEN
BEGIN
(*%IFT PCREF *)
% WORKCALL := NIL;\
(*%ENDC PCREF *)
syty := othersy;
readbuffer;
END
ELSE
syty := delsy[':'];
END;
'\':
BEGIN
readbuffer;
IF incondcomp THEN
BEGIN
incondcomp := false;
GOTO 111;
END
ELSE
syty := othersy;
END;
'[':
BEGIN
syty := lbracket; readbuffer; parenthese(rbracket);
END;
OTHERS:
BEGIN
syty := delsy [ch];
readbuffer;
END
END (*CASE CH OF*);
1:
notokenyet := false;
(*%IFT PCREF *)
% IF WORKCALL <> NIL THEN\
% INSERTCALL;\
(*%ENDC PCREF *)
END (*INSYMBOL*) ;
(*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
PROCEDURE recdef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
PROCEDURE casedef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
PROCEDURE parenthese;
(*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*PARENTHESE*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := spaces + bufferptr - 2;
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
insymbol;
REPEAT
CASE syty OF
casesy :
casedef;
recordsy :
recdef;
(*%IFT PCREF *)
% SEMICOLON, LPARENT:\
% BEGIN\
% DECLARING := TRUE;\
% INSYMBOL;\
% END;\
% EQLSY, COLON:\
% BEGIN\
% DECLARING := FALSE;\
% INSYMBOL;\
% END;\
(*%ENDC PCREF *)
OTHERS :
insymbol;
END;
(*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
loopsy..ifsy,forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = rparent THEN
BEGIN
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
insymbol;
END
ELSE
error(missgrpar);
END (*PARENTHESE*) ;
BEGIN (*CASEDEF*)
variant_level := variant_level+1;
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + lastspaces - syleng + 3;
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
insymbol;
(*%IFT PCREF *)
% DECLARING := FALSE;\
(*%ENDC PCREF *)
REPEAT
IF syty = lparent THEN
parenthese
ELSE
insymbol
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
spaces := oldspacesmark;
variant_level := variant_level-1;
END (*CASEDEF*) ;
BEGIN (*RECDEF*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
insymbol;
REPEAT
CASE syty OF
casesy : casedef;
recordsy : recdef;
(*%IFT PCREF *)
% SEMICOLON, LPARENT:\
% BEGIN\
% DECLARING := TRUE;\
% INSYMBOL;\
% END;\
% EQLSY, COLON:\
% BEGIN\
% DECLARING := FALSE;\
% INSYMBOL;\
% END;\
% ENDSY:;\
(*%ENDC PCREF *)
OTHERS : insymbol
END;
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
oldspaces := true;
lastspaces := spaces - feed;
spaces := oldspacesmark;
IF syty = endsy THEN
BEGIN
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
insymbol;
END
ELSE
error(missgend);
END (*RECDEF*) ;
(*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat*)
PROCEDURE statement;
VAR
oldspacesmark, (*SPACES AT ENTRY OF THIS PROCEDURE*)
curblocknr : integer; (*CURRENT BLOCKNUMBER*)
PROCEDURE endedstatseq(endsym: symbol; letter: char);
BEGIN
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
BEGIN
error(missgend);
IF NOT (syty IN begsym) THEN
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
END;
IF forcing THEN
writeline(bufferptr-syleng);
(*%IFT PCREF *)
% EMARKTEXT := LETTER;\
% EMARKNR := CURBLOCKNR;\
(*%ENDC PCREF *)
oldspaces := true;
IF (endsym = endsy) THEN
BEGIN
IF indentbegin = 0 THEN
lastspaces := max(0,spaces-begexd)
ELSE
lastspaces := max(0,spaces-indentbegin);
IF syty <> endsy THEN
error(missgend)
END
ELSE
BEGIN
lastspaces := max(0,spaces - feed);
IF syty <> endsym THEN
error(missguntil);
END;
END (*ENDEDSTATSEQ*);
PROCEDURE compstat;
BEGIN (*COMPSTAT*)
IF indentbegin = 0 THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-begexd)
END;
END
ELSE
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - indentbegin);
END;
(*%IFT PCREF *)
% BMARKTEXT := 'B';\
% MARKSYTY := PREVSYTY;\
% insymbol;\
% IF forcing THEN\
% BEGIN\
% IF MARKSYTY = OTHERSY THEN\
% nocountyet := TRUE;\
% WRITELINE(BUFFERPTR-SYLENG);\
% END;\
(*%ELSE PCREF (IFF) *)
insymbol;
IF forcing THEN
writeline(bufferptr-syleng);
(*%ENDC PCREF (ELSE) (IFF) *)
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
(*%IFT PCREF *)
% IF FORCING THEN\
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
END (*COMPSTAT*) ;
PROCEDURE casestat;
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*CASESTAT*)
(*%IFT PCREF *)
% BMARKTEXT := 'C';\
(*%ENDC PCREF *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
insymbol;
statement;
IF syty = ofsy THEN
(*%IFT PCREF *)
% BEGIN\
% IF FORCING THEN\
% WRITELINE (BUFFERPTR)\
% END\
(*%ELSE PCREF (IFF) *)
writeline (bufferptr)
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
error (missgof);
LOOP
REPEAT
REPEAT
insymbol;
UNTIL syty IN [colon, functionsy .. eobsy];
IF syty = colon THEN
BEGIN
oldspacesmark := spaces;
lastspaces := spaces;
spaces := spaces + feed;
(* SPACES := BUFFERPTR - BUFFMARK + SPACES - 4; *)
oldspaces := true;
thendo := true;
insymbol;
statement;
IF syty = semicolon THEN
insymbol;
spaces := oldspacesmark;
END;
UNTIL syty IN endsym;
EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
error (missgend);
END;
(*%IFT PCREF *)
% IF FORCING THEN\
% writeline(bufferptr-syleng);\
% EMARKTEXT := 'E';\
% EMARKNR := CURBLOCKNR;\
% IF syty = endsy THEN\
% BEGIN\
% insymbol ;\
% IF FORCING THEN\
(*%ELSE PCREF (IFF) *)
writeline(bufferptr-syleng);
IF syty = endsy THEN
BEGIN
insymbol ;
(*%ENDC PCREF (ELSE) (IFF) *)
writeline(bufferptr-syleng);
END
ELSE
error (missgend);
END (*CASESTAT*) ;
PROCEDURE loopstat;
BEGIN (*LOOPSTAT*)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*%IFT PCREF *)
% BMARKTEXT := 'L';\
% MARKSYTY := PREVSYTY;\
% INSYMBOL;\
% IF FORCING THEN\
% BEGIN\
% IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN\
% nocountyet := TRUE;\
% WRITELINE(BUFFERPTR-SYLENG);\
% END;\
(*%ELSE PCREF (IFF) *)
insymbol;
(*%ENDC PCREF (ELSE) (IFF) *)
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
IF syty = exitsy THEN
BEGIN
(*%IFT PCREF *)
% IF FORCING THEN\
% writeline(bufferptr-syleng);\
% oldspaces := true;\
% lastspaces := spaces-feed;\
% EMARKTEXT := 'X';\
% EMARKNR := CURBLOCKNR;\
% INSYMBOL; INSYMBOL;\
% PREVSYTY := EXITSY;\
(*%ELSE PCREF (IFF) *)
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := spaces-feed;
insymbol; insymbol;
(*%ENDC PCREF (ELSE) (IFF) *)
END
ELSE
error(missgexit);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
(*%IFT PCREF *)
% IF FORCING THEN\
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
END (*LOOPSTAT*) ;
PROCEDURE ifstat;
VAR
oldspacesmark: integer;
BEGIN (*IFSTAT*)
oldspacesmark := spaces;
(*%IFT PCREF *)
% MARKSYTY := PREVSYTY;\
% BMARKTEXT := 'I';\
(*%ENDC PCREF *)
if not elsehere then
begin
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
spaces := lastspaces + bufferptr - buffmark + feed - 4;
end (*if not elsehere*);
insymbol;
statement; (*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
IF syty = thensy THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
(*%IFT PCREF *)
% EMARKTEXT := 'T';\
% EMARKNR := CURBLOCKNR;\
% IF forcing THEN\
% BEGIN\
% IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN\
% nocountyet := TRUE;\
% WRITELINE(BUFFERPTR);\
% END\
(*%ELSE PCREF (IFF) *)
IF forcing THEN
writeline(bufferptr)
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
thendo := true;
(*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
insymbol;
statement;
END
ELSE
error (missgthen);
IF syty = elsesy THEN (*PARSE THE ELSE PART*)
BEGIN
(*%IFT PCREF *)
% IF FORCING THEN\
% writeline(bufferptr-syleng);\
% EMARKTEXT := 'S';\
% EMARKNR := CURBLOCKNR;\
(*%ELSE PCREF (IFF) *)
writeline(bufferptr-syleng);
(*%ENDC PCREF (ELSE) (IFF) *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing and not elseifing THEN
(*%IFT PCREF *)
% BEGIN\
% nocountyet := TRUE;\
% WRITELINE(BUFFERPTR);\
% END\
(*%ELSE PCREF (IFF) *)
writeline(bufferptr)
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
thendo := true;
elsehere := true;
insymbol;
statement;
END;
(*%IFT PCREF *)
% IF FORCING THEN\
% begin\
% oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)\
% writeline(bufferptr-syleng);\
% end;\
(*%ELSE PCREF (IFF) *)
oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)
writeline(bufferptr-syleng);
(*%ENDC PCREF (ELSE) (IFF) *)
spaces := oldspacesmark;
END (*IFSTAT*) ;
PROCEDURE labelstat;
BEGIN (*LABELSTAT*)
lastspaces := level * feed;
oldspaces := true;
insymbol;
(*%IFT PCREF *)
% IF FORCING THEN\
% BEGIN\
% nocountyet := TRUE;\
% WRITELINE(BUFFERPTR-SYLENG);\
% END;\
(*%ELSE PCREF (IFF) *)
writeline(bufferptr-syleng);
(*%ENDC PCREF (ELSE) (IFF) *)
END (*LABELSTAT*) ;
PROCEDURE repeatstat;
BEGIN
(*%IFT PCREF *)
% BMARKTEXT := 'R';\
% MARKSYTY :=PREVSYTY;\
% IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN\
% nocountyet := TRUE;\
(*%ENDC PCREF *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
endedstatseq(untilsy, 'U');
IF syty = untilsy THEN
BEGIN
insymbol;
statement;
(*%IFT PCREF *)
% IF FORCING THEN\
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
END (*REPEATSTAT*) ;
BEGIN (*STATEMENT*)
oldspacesmark := spaces; (*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT*)
IF syty = intconst THEN
BEGIN
insymbol;
IF syty = colon THEN
labelstat;
END;
IF syty IN begsym THEN
BEGIN
(*%IFT PCREF *)
% BLOCKNR := (BLOCKNR + 1) MOD 1000;\
% CURBLOCKNR := BLOCKNR;\
% BMARKNR := CURBLOCKNR;\
(*%ENDC PCREF *)
IF NOT thendo THEN
BEGIN
(*%IFT PCREF *)
% IF FORCING THEN\
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
IF (syty <> beginsy) THEN
spaces := spaces + feed
ELSE
spaces:=spaces + indentbegin;
END;
CASE syty OF
beginsy : compstat;
loopsy : loopstat;
casesy : casestat;
ifsy : ifstat;
repeatsy: repeatstat
END;
END
ELSE
BEGIN
IF forcing THEN
IF syty IN [forsy,whilesy] THEN
writeline(bufferptr-syleng);
(*%IFT PCREF *)
% IF SYTY = GOTOSY THEN\
% GOTOINLINE:=TRUE;\
(*%ENDC PCREF *)
WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
insymbol;
IF syty = dosy THEN
BEGIN
IF NOT thendo THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
spaces := spaces + feed;
IF NOT forcing THEN
thendo := true;
END;
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END;
spaces := oldspacesmark;
END (*STATEMENT*) ;
(*]BLOCK*)
BEGIN (*BLOCK*)
(*%IFT PCREF *)
% STMTPART := FALSE;\
% DECLARING := TRUE;\
(*%ENDC PCREF *)
REPEAT
insymbol;
UNTIL syty IN relevantsym;
level := level + 1;
spaces := level * feed;
(*%IFT PCREF *)
% (*HANDLE NESTING LIST*)\
% CURPROC := LISTPTR;\
% LOCPROCSTL := PROCSTRUCF;\
% WITH PROCSTRUCDATA, ITEM DO\
% IF EXISTS THEN\
% WITH PROCNAME↑ DO\
% BEGIN\
% IF PROCDATA <> NIL THEN\
% BEGIN\
% IF EXTERNFLAG = 'F' THEN\
% PROCDATA := NIL\
% ELSE\
% IF EXTERNFLAG = ' ' THEN\
% EXTERNFLAG := 'D';\
% LOCPROCSTL := PROCDATA;\
% END;\
% IF PROCDATA = NIL THEN\
% BEGIN\
% IF (SYTY IN [FORWARDSY,EXTERNSY]) THEN\
% IF SYTY = EXTERNSY THEN\
% EXTERNFLAG := 'E'\
% ELSE\
% EXTERNFLAG := 'F';\
% NEW(PROCSTRUCL↑.NEXTPROC);\
% PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;\
% PROCDATA := PROCSTRUCL;\
% PROCSTRUCL↑ := ITEM;\
% LOCPROCSTL := PROCSTRUCL;\
% END;\
% PROCSTRUCDATA.EXISTS := FALSE\
% END;\
(*%ENDC PCREF *)
REPEAT
fwddecl := false;
WHILE syty IN decsym DO (*DECLARATIONS: LABELS, TYPES, VARS*)
BEGIN
(*%IFT PCREF *)
% IF FORCING THEN\
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty = programsy THEN
BEGIN
programpresent := true;
insymbol;
prog_name := sy;
(*%IFT PCREF *)
% PROCSTRUCF↑.PROCNAME := LISTPTR;\
% LISTPTR↑.PROCDATA := PROCSTRUCF;\
% LISTPTR↑.PROFUNFLAG := 'M';\
% DECLARING := FALSE;\
(*%ENDC PCREF *)
writeln(tty);
write(tty,version:verlength,': ',old_name:6,' [ ',prog_name,' ] PAGE');
FOR i := 1 TO pagecnt DO
write (tty, i:3,'..');
break(tty);
END
ELSE (*SYTY <> PROGRAMSY*)
BEGIN
(*%IFT PCREF *)
% DECLARING := TRUE;\
(*%ENDC PCREF *)
IF forcing THEN
writeline(bufferptr);
END (*SYTY <> PROGRAMSY*);
(*%IFT PCREF *)
% REPEAT\
% INSYMBOL;\
% CASE SYTY OF\
% SEMICOLON, LPARENT : DECLARING := TRUE;\
% EQLSY, COLON : DECLARING := FALSE;\
% RECORDSY: RECDEF;\
% END;\
% IF SYTY = RECORDSY THEN\
% RECDEF;\
% UNTIL SYTY IN RELEVANTSYM;\
% END;\
% DECLARING := FALSE;\
% WHILE SYTY IN PROSYM DO (*PROCEDURE AND FUNCTION DECLARATIONS*)\
% BEGIN\
% IF FORCING THEN\
% WRITELINE(BUFFERPTR-SYLENG);\
% OLDSPACES := TRUE;\
% LASTSPACES := MAX(0,SPACES-FEED);\
% LASTPROCNAME := CURPROCNAME;\
% IF SYTY <> INITPROCSY THEN\
% BEGIN\
% ITISAPROC := SYTY = PROCEDURESY;\
% DECLARING := TRUE;\
% INSYMBOL;\
% CURPROCNAME := LISTPTR↑.NAME;\
% IF ITISAPROC THEN\
% LISTPTR↑.PROFUNFLAG := 'P'\
% ELSE\
% LISTPTR↑.PROFUNFLAG := 'F';\
% WITH PROCSTRUCDATA, ITEM DO\
% BEGIN\
% EXISTS := TRUE;\
% PROCNAME := LISTPTR;\
% NEXTPROC := NIL;\
% LINENR := LINECNT;\
% PAGENR := PAGECNT;\
% PROCLEVEL := LEVEL;\
% PRINTED := FALSE;\
% FIRSTCALL := NIL;\
% END;\
% END\
% ELSE\
% CURPROCNAME := 'INITPROCED';\
% BLOCK;\
% CURPROCNAME := LASTPROCNAME;\
% DECLARING := FALSE;\
% STMTPART := FALSE;\
% IF SYTY = SEMICOLON THEN\
% INSYMBOL;\
% END (*WHILE SYTY IN PROSYM*)\
(*%ELSE PCREF (IFF) *)
REPEAT
insymbol;
IF syty = recordsy THEN
recdef;
UNTIL syty IN relevantsym;
END;
WHILE syty IN prosym DO (*PROCEDURE AND FUNCTION DECLARATIONS*)
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty <> initprocsy THEN
insymbol;
block;
IF syty = semicolon THEN
insymbol;
END (*WHILE SYTY IN PROSYM*)
(*%ENDC PCREF (ELSE) (IFF) *)
(*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
UNTIL NOT fwddecl;
IF forcing THEN
writeline(bufferptr-syleng);
level := level - 1;
spaces := level * feed;
IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
BEGIN
IF (level = 0) AND (syty = point) THEN
nobody := true
ELSE
error (begerrinblkstr);
WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
insymbol
END;
IF syty = beginsy THEN
(*%IFT PCREF *)
% BEGIN\
% COUNTLINE := SOURCELINE; (*TO GET THE COUNT IN THE LINE OF THE BEGIN*)\
% COUNTPAGE := SOURCEPAGE;\
% DECLARING := FALSE;\
% STMTPART := TRUE; (*TO PREVENT BARS IN DECLARATIONS*)\
% LOCPROCSTL↑.BEGLINE := LINECNT + 1;\
% LOCPROCSTL↑.BEGPAGE := PAGECNT;\
% STATEMENT;\
% LOCPROCSTL↑.ENDLINE := LINECNT + 1;\
% LOCPROCSTL↑.ENDPAGE := PAGECNT;\
% END\
(*%ELSE PCREF (IFF) *)
statement
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
IF NOT nobody THEN
BEGIN
fwddecl := true;
insymbol;
END;
IF level = 0 THEN
IF programpresent THEN
BEGIN
IF nobody THEN
BEGIN
error (missgmain);
errcount := errcount - 1;
END;
IF syty <> point THEN
error(missgpoint);
writeline(bufflen+2);
writeln(tty);
writeln (tty,errcount:4,' ERROR(S) DETECTED'); break(tty);
END (*IF LEVEL = 0*);
END (*BLOCK*) ;
(*PRINT_XREF_LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
(*%IFT PCREF *)
%PROCEDURE PRINT_XREF_LIST;\
% VAR\
% PRED : LISTPTRTY;\
% INDEXCH : CHAR; (*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN*)\
% LISTPGNR : BOOLEAN; (*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)\
% ITEMLEN: INTEGER; (*LENGTH OF A PRINTED LINENUMBER, 9 OR 12*)\
% THISCALL : CALLEDTY;\
% OLDCROSSING: BOOLEAN;\
%\
%\
% PROCEDURE CHECKPAGE(HEADING: BOOLEAN);\
% BEGIN\
% IF REALLINCNT = MAXLINE THEN\
% BEGIN\
% IF HEADING THEN\
% HEADER (LISTPTR↑.NAME)\
% ELSE\
% HEADER (BLANKS);\
% END;\
% REALLINCNT:=REALLINCNT+1;\
% END(*CHECKPAGE*);\
%\
% PROCEDURE WRITEPROCNAME (PROCSTRUCL: PROCSTRUCTY; DEPTH: INTEGER; MARK: CHAR; NUMBERING: BOOLEAN);\
% BEGIN (*WRITEPROCNAME*)\
% WRITELN(CROSSLIST);\
% CHECKPAGE(FALSE);\
% WITH PROCSTRUCL↑, PROCNAME↑ DO\
% BEGIN\
% IF NUMBERING THEN\
% WRITE (CROSSLIST, LINECNT * INCREMENT:LINNUMSIZE+1, ' ');\
% IF DEPTH > 2 THEN\
% WRITE (CROSSLIST, '. ',DOTS:DEPTH-1)\
% ELSE\
% WRITE (CROSSLIST, '.':DEPTH+1);\
% WRITE (CROSSLIST, NAME : 10, ' (', PROFUNFLAG, ')',\
% MARK:2, EXTERNFLAG:2, CHR(HT), LINENR * INCREMENT : 8);\
% IF LISTPGNR OR (PAGENR > 1) THEN\
% WRITE(CROSSLIST, '/',PAGENR : 2);\
% IF (MARK = ' ') AND NOT (EXTERNFLAG IN ['E', 'F']) THEN\
% BEGIN\
% WRITE (CROSSLIST, BEGLINE * INCREMENT: LINNUMSIZE + 3);\
% IF LISTPGNR THEN\
% WRITE (CROSSLIST, '/', BEGPAGE: 2);\
% WRITE (CROSSLIST, ENDLINE * INCREMENT: LINNUMSIZE + 3);\
% IF LISTPGNR THEN\
% WRITE (CROSSLIST, '/', ENDPAGE:2);\
% END\
% ELSE\
% IF EXTERNFLAG = 'F' THEN\
% EXTERNFLAG := ' ';\
% END;\
% END (*WRITEPROCNAME*);\
%\
% PROCEDURE WRITELINENR (SPACES : INTEGER);\
%\
% VAR\
% LINK : LINEPTRTY; (*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN*)\
% MAXCNT, (*MAXIMUM ALLOWABLE VALUE OF COUNT*)\
% COUNT : INTEGER; (*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)\
% BEGIN (*WRITELINENR*)\
% COUNT := 0;\
% MAXCNT := (MAXCROSSCH + 1 - SPACES) DIV ITEMLEN; (*ITEMS ARE ITEMLEN CHARS EACH*)\
% LINK := LISTPTR↑.FIRST;\
% REPEAT\
% IF COUNT = MAXCNT THEN\
% BEGIN\
% WRITELN(CROSSLIST);\
% CHECKPAGE(TRUE);\
% WRITE (CROSSLIST, ' ' : SPACES);\
% COUNT := 0;\
% END;\
% COUNT := COUNT + 1;\
% WITH LINK↑ DO\
% BEGIN\
% WRITE (CROSSLIST, LINENR * INCREMENT : LINNUMSIZE + 1);\
% IF LISTPGNR THEN\
% WRITE(CROSSLIST, '/',PAGENR : 2);\
% WRITE (CROSSLIST,DECLFLAG);\
% LINK := CONTLINK;\
% END;\
% UNTIL LINK = NIL;\
% END (*WRITELINENR*) ;\
%\
% PROCEDURE DUMPCALL (THISPROC: PROCSTRUCTY; DEPTH: INTEGER);\
% VAR\
% THISCALL: CALLEDTY;\
%\
% BEGIN (*DUMPCALL*)\
% LINECNT := LINECNT + 1;\
% WITH THISPROC↑ DO\
% IF PRINTED THEN\
% WRITEPROCNAME (THISPROC, DEPTH,'*', TRUE)\
% ELSE\
% BEGIN\
% WRITEPROCNAME (THISPROC, DEPTH, ' ', TRUE);\
% PRINTED := TRUE;\
% LINENR := LINECNT;\
% PAGENR := PAGECNT;\
% THISCALL := FIRSTCALL;\
% WHILE THISCALL <> NIL DO\
% BEGIN\
% DUMPCALL (THISCALL↑.WHOM, DEPTH + FEED);\
% THISCALL := THISCALL↑.NEXTCALL;\
% END;\
% END;\
% END (*DUMPCALL*);\
%\
% BEGIN (*PRINT_XREF_LIST*)\
% OLDCROSSING := CROSSING;\
% CROSSING := TRUE;\
% LISTPGNR := PAGECNT > 1;\
% ITEMLEN := LINNUMSIZE + 2;\
% IF LISTPGNR THEN\
% ITEMLEN := ITEMLEN + 3;\
% WITH FIRSTNAME ['M']↑ DO (*DELETE 'MAIN'*)\
% IF RLINK = NIL THEN\
% FIRSTNAME ['M'] := LLINK\
% ELSE\
% BEGIN\
% LISTPTR := RLINK;\
% WHILE LISTPTR↑.LLINK <> NIL DO\
% LISTPTR := LISTPTR↑.LLINK;\
% LISTPTR↑.LLINK := LLINK;\
% FIRSTNAME ['M'] := RLINK;\
% END;\
% INDEXCH := 'A';\
% WHILE (INDEXCH < 'Z') AND (FIRSTNAME [INDEXCH] = NIL) DO\
% INDEXCH := SUCC (INDEXCH);\
% IF FIRSTNAME [INDEXCH] <> NIL THEN\
% BEGIN\
% IF REFING THEN\
% BEGIN\
% PAGECNT := PAGECNT + 1;\
% PAGECNT2 := 0;\
% HEADER (BLANKS);\
% WRITELN (CROSSLIST, 'CROSS REFERENCE LISTING OF IDENTIFIERS');\
% WRITELN (CROSSLIST, '**************************************');\
% WRITE(TTY,'CROSS REFERENCE..'); BREAK;\
% REALLINCNT:= REALLINCNT + 3;\
% FOR INDEXCH := INDEXCH TO 'Z' DO\
% WHILE FIRSTNAME [INDEXCH] <> NIL DO\
% BEGIN\
% LISTPTR := FIRSTNAME [INDEXCH];\
% WHILE LISTPTR↑.LLINK <> NIL DO\
% BEGIN\
% PRED := LISTPTR;\
% LISTPTR := LISTPTR↑.LLINK;\
% END;\
% IF LISTPTR = FIRSTNAME [INDEXCH] THEN\
% FIRSTNAME [INDEXCH] := LISTPTR↑.RLINK\
% ELSE\
% PRED↑.LLINK := LISTPTR↑.RLINK;\
% WRITELN(CROSSLIST);\
% CHECKPAGE(TRUE);\
% WRITE (CROSSLIST, LISTPTR↑.PROFUNFLAG, LISTPTR↑.NAME : 11);\
% WRITELINENR (12);\
% END;\
% END;\
%\
% IF PROCSTRUCL <> PROCSTRUCF THEN\
% BEGIN\
% IF DECNESTING THEN\
% BEGIN\
% PAGECNT := PAGECNT + 1;\
% PAGECNT2 := 0;\
% WRITELN (CROSSLIST);\
% HEADER ('*DECLARAT*');\
% WRITELN (CROSSLIST, 'NESTING OF PROCEDURE-FUNCTION DECLARATION');\
% WRITELN (CROSSLIST, '*****************************************');\
% WRITELN (CROSSLIST, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');\
% WRITE(TTY,' PROCEDURE DECLARATIONS..'); BREAK;\
% REALLINCNT:= REALLINCNT + 4;\
% PROCSTRUCL := PROCSTRUCF;\
% REPEAT\
% WRITEPROCNAME (PROCSTRUCL, PROCSTRUCL↑.PROCLEVEL * 4, ' ', FALSE);\
% PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;\
% UNTIL PROCSTRUCL = NIL;\
% END;\
% IF CALLNESTING THEN\
% BEGIN\
% PAGECNT := PAGECNT + 1;\
% PAGECNT2 := 0;\
% WRITELN (CROSSLIST);\
% HEADER ('* CALLS * ');\
% WRITELN (CROSSLIST, 'NESTING OF PROCEDURE-FUNCTION CALLS');\
% WRITELN (CROSSLIST, '***********************************');\
% WRITELN (CROSSLIST, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');\
% WRITE(TTY,' PROCEDURE CALLS..'); BREAK;\
% REALLINCNT := REALLINCNT + 4;\
% LINECNT := 0;\
% PROCSTRUCL := PROCSTRUCF;\
% WHILE PROCSTRUCL <> NIL DO\
% BEGIN\
% IF NOT PROCSTRUCL↑.PRINTED THEN\
% DUMPCALL (PROCSTRUCL, 0);\
% PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;\
% END;\
% END;\
% END;\
% END;\
% CROSSING := OLDCROSSING;\
% END (*PRINT_XREF_LIST*) ;\
(*%ENDC PCREF *)
(*MAIN PROGRAM*)
BEGIN
settime;
getdirectives;
initialize;
(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
(*%IFT SAIL *)
maxinc := (1000 DIV increment);
(*%else sail (IFF) *)
%MAXINC := (99999 DIV INCREMENT);\
%IF MAXINC > 4000 THEN\
% MAXINC := 4000;\
(*%endc sail (ELSE) (IFF) *)
LOOP
block;
EXIT IF NOT programpresent OR (syty = eobsy);
(*%IFT PCREF *)
% IF COUNTING THEN\
% BEGIN\
% WRITELN(TTY);\
% WRITELN(TTY,'MAXIMUM COUNT: ',MAXCOUNTTIMES,' AT LINE ',MAXCOUNTLINE*INCREMENT:5,'/',MAXCOUNTPAGE:2);\
% IF CROSSING THEN\
% BEGIN\
% WRITELN(CROSSLIST);\
% WRITELN(CROSSLIST,'MAXIMUM COUNT: ',MAXCOUNTTIMES,' AT LINE ',MAXCOUNTLINE*INCREMENT:5,'/',MAXCOUNTPAGE:2);\
% END;\
% END;\
% IF REFING OR DECNESTING OR CALLNESTING THEN\
% PRINT_XREF_LIST;\
% DISPOSE(HEAPMARK); (*RELEASE THE ENTIRE HEAP*)\
(*%ENDC PCREF *)
reinitialize;
END;
(*%IFT PCREF *)
%IF COUNTING THEN\
% REWRITE(COUNTFILE);\
%\
%GETNEXTCALL (LINK_NAME, LINK_DEVICE);\
(*%ENDC PCREF *)
timereport(ttyoutput, ' ');
(*%IFT PCREF *)
%IF LINK_NAME <> ' ' THEN\
% CALL (LINK_NAME, LINK_DEVICE);\
(*%ENDC PCREF *)
END (*PCROSS*).